home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / splitcal.bas < prev    next >
BASIC Source File  |  1988-11-09  |  3KB  |  77 lines
  1. 100 CLS:PRINT TAB(10);"PRINT A CALENDAR FOR ANY YEAR SINCE 1582":PRINT
  2. 110 '
  3. 120 ' Judson D. McClendon
  4. 130 ' 844 Sun Valley Road
  5. 140 ' Birmingham, AL 35215
  6. 150 '
  7. 160 ' Compuserve 74415,1003
  8. 165 ' Additions for split year by Lew Paper
  9. 170 '
  10. 200 DEF FNDOW(M,D,Y)=(D+M+M+INT((M+1)*.6)+Y+Y\4-Y\100+Y\400+1) MOD 7
  11. 210 DIM MON$(23),MAX(23),DOM(23),DOW(23) ' Dimension by L.P.
  12. 220 FOR I=1 TO 12 :READ MON$(I) :NEXT
  13. 230 FOR I=1 TO 11 : MON$(I + 12) = MON$(I): NEXT ' L.P.
  14. 240 DATA "   J A N U A R Y   ","  F E B R U A R Y  ","     M A R C H    "
  15. 250 DATA "     A P R I L     ","       M A Y       ","      J U N E     "
  16. 260 DATA "      J U L Y      ","    A U G U S T    "," S E P T E M B E R"
  17. 270 DATA "   O C T O B E R   ","  N O V E M B E R  ","  D E C E M B E R "
  18. 280 FOR I=1 TO 12 :READ MAX(I) :NEXT
  19. 290 FOR I=1 TO 11: MAX(I + 12) = MAX(I): NEXT ' L.P.
  20. 300 DATA 31,28,31,30,31,30,31,31,30,31,30,31
  21. 400 INPUT "What year to start: ",YEAR1 ' Variable name by L.P.
  22. 410 IF YEAR<100 THEN YEAR=YEAR+1900  ' Assume 20th century if not specified
  23. 420 IF YEAR<1582 THEN PRINT "Not valid before 1582" :GOTO 400
  24. 430 YEAR2 = YEAR1 + 1 ' L.P.
  25. 440 INPUT "What month to start: ",MONTH1 ' L.P.
  26. 450 IF (MONTH1 < 1) OR (MONTH1 > 12) THEN PRINT, "Not a valid month": GOTO 440 'L.P.
  27. 460 MONTH2 = MONTH1 + 11 ' L.P.
  28. 470 IF ((YEAR1 MOD 4)<>0) OR ((YEAR1 MOD 100)=0 AND (YEAR1 MOD 400)<>0) THEN 490 ' L.P. for variable and branch
  29. 480 MAX(2)=29
  30. 490 IF ((YEAR2 MOD 4)<>0) OR ((YEAR2 MOD 100)=0 AND (YEAR2 MOD 400)<>0) THEN 510 ' L.P.
  31. 500 MAX(14) = 29 ' L.P.
  32. 510 PRINT :INPUT "How many copies";COPIES
  33. 600 FOR COUNT=1 TO COPIES
  34. 610   LPRINT
  35. 620   IF MONTH1 = 1 THEN LPRINT TAB(27);"CALENDAR FOR THE YEAR";YEAR1: GOTO 640 ' L.P. for IF and GOTO
  36. 630   LPRINT TAB(24);"CALENDAR FOR THE YEARS";YEAR1; " -"; YEAR2 ' L.P.
  37. 640   LPRINT ' L.P.
  38. 650   LPRINT :LPRINT
  39. 660   FOR MM=MONTH1 TO MONTH2 STEP 3 ' L.P. FOR MONTH?
  40. 670     FOR MONTH=MM TO MM+2
  41. 680       LPRINT TAB((MONTH-MM)*24+6);MON$(MONTH);
  42. 690     NEXT
  43. 700     LPRINT ' L.P.
  44. 710     IF MONTH1 = 1 THEN 770 ' L.P.
  45. 720       FOR MONTH=MM TO MM+2 ' L.P.
  46. 730         LPRINT TAB((MONTH-MM)*24+12); ' L.P.
  47. 740         IF MONTH < 13 THEN LPRINT YEAR1; ELSE LPRINT YEAR2; ' L.P.
  48. 750       NEXT ' L.P.
  49. 760       LPRINT ' L.P.
  50. 770     LPRINT ' L.P. to remove one LPRINT
  51. 780     FOR MONTH=MM TO MM+2
  52. 790       LPRINT TAB((MONTH-MM)*24+6)"SU MO TU WE TH FR SA";
  53. 800       DAY=1 :GOSUB 1100 :DOW(MONTH)=DOW :DOM(MONTH)=1
  54. 810     NEXT
  55. 820     LPRINT
  56. 830     FOR WEEK=1 TO 6
  57. 840       FOR MONTH=MM TO MM+2
  58. 850         WHILE DOM(MONTH)<=MAX(MONTH) AND DOW(MONTH)<7
  59. 860           LPRINT TAB((MONTH-MM)*24+DOW(MONTH)*3+6);"";
  60. 870           LPRINT USING "##";DOM(MONTH);
  61. 880           DOM(MONTH)=DOM(MONTH)+1
  62. 890           DOW(MONTH)=DOW(MONTH)+1
  63. 900         WEND
  64. 910         IF DOW(MONTH)>6 THEN DOW(MONTH)=0
  65. 920       NEXT
  66. 930       LPRINT
  67. 940     NEXT
  68. 950     LPRINT :LPRINT :LPRINT
  69. 960   NEXT
  70. 970   LPRINT CHR$(12);
  71. 980 NEXT
  72. 990 SYSTEM
  73. 1100 IF MONTH<3 THEN DOW=FNDOW(MONTH+12,DAY,YEAR1-1): RETURN ' L.P. to remove ELSE
  74. 1110 IF MONTH<15 THEN DOW=FNDOW(MONTH,DAY,YEAR1): RETURN ' L.P. for 15 and RETURN
  75. 1120 DOW=FNDOW(MONTH-12,DAY,YEAR2) ' L.P.
  76. 1130 RETURN
  77.